module Parsec where

import Data.Char
import Control.Applicative
import Data.List (isPrefixOf)

type ParseResult = Either ParseError

data ParseError = ParseError String deriving (Eq, Show)

newtype Parser a = Parser { runParser :: String -> ParseResult (String, a) }


instance Functor Parser where
    fmap f (Parser p) = Parser $ \input -> do
        -- Try run parser
        (input', x) <- p input
        -- If success, take the value into `f`
        return (input', f x)


instance Applicative Parser where
    -- Get a parser always get `x`
    pure x = Parser $ \input -> Right (input, x)
    -- (<*>) :: Applicative f => f (a -> b) -> f a -> f b
    -- p1 :: String -> ParseResult (String, a -> b)
    -- p2 :: String -> ParseResult (String, a)
    (Parser p1) <*> (Parser p2) = Parser $ \input -> do
        -- Try parse a function `(a -> b)`
        (input', f) <- p1 input
        -- Use left input to parse a `a`
        (input'', a) <- p2 input'
        -- Call function with a 
        return (input'', f a)


instance Alternative Parser where
    -- empty :: Alternative f => f a
    empty = Parser $ \input -> Left $ ParseError "empty"
    -- (<|>) :: Alternative f => f a -> f a -> f a
    (Parser p1) <|> (Parser p2) = Parser $ \input -> case p1 input of
        Right res -> Right res
        Left err -> p2 input


charP :: Char -> Parser Char 
charP c = Parser f
    where 
        f (x:xs) = if x == c
            then Right (xs, c)
            else Left . ParseError $ "Expected '" ++ [c] ++ "', but found '" ++ [x] ++ "'"
        f [] = Left . ParseError $ "Expected '" ++ [c] ++ "', but get empty string"


predP :: (Char -> Bool) -> Parser Char
predP pred = Parser f
    where
        f (x:xs) = if pred x 
            then Right (xs, x)
            else Left . ParseError $ [x] ++ " unmatch the pred!"
        f [] = Left . ParseError $ "Empty string unmatch the pred!"


{-
    traverse
    :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b)

    traverse :: Applicative f => (a -> f b) -> [a] -> f [b]
    traverse :: (Char -> Parser Char) -> [Char] -> Parser [Char]

    sequenceA :: (Traversable t, Applicative f) => t (f a) -> f (t a)
    sequenceA :: [Parser Char] -> Parser [Char]
-}
stringP :: String -> Parser String
stringP str = Parser $ \input ->
    case runParser (sequenceA $ map charP str) input of 
        Left _ -> 
            Left $ ParseError ("Expected \"" ++ str ++ "\", but found \"" ++ input ++ "\"")
        result -> result


{-
    (:) is a function take a and [a], and get [a]
    (:) ::  a -> [a] -> [a]

    and <$> :: Functor f => (a -> b) -> f a -> f b

    So, we know:
    (:) <$> element will get call with:
    <$> :: b -> ([b] -> [b]) -> Parser b -> Parser ([b] -> [b])

    and get `Parser ([b] -> [b])`


    1. `(:) <$> element` ===> Parser ([b] -> [b])
    2. `many (sep *>  element)` ===> Parser [b]
    3. `(:) <$> element <*> many (sep *>  element)` ===> Parser [b]
-}
sepByP :: Parser a -> Parser b -> Parser [b]
sepByP sep element = 
    ((:) <$> element <*> many (sep *>  element)) <|> 
    pure []


oneOfP :: String -> Parser Char
oneOfP dest = Parser f
    where
        f (x:xs) = if x `elem` dest 
            then Right (xs, x)
            else Left . ParseError $ "Expected one of '" ++ dest ++ "', but found '" ++ [x] ++ "'"
        f [] = Left . ParseError $ "Expected one of '" ++ dest ++ "', but get empty string"


noneOfP :: String -> Parser Char
noneOfP dest = Parser f
    where
        f (x:xs) = if not (x `elem` dest)
            then Right (xs, x)
            else Left . ParseError $ "Expected one of '" ++ dest ++ "', but found '" ++ [x] ++ "'"
        f [] = Left . ParseError $ "Expected one of '" ++ dest ++ "', but get empty string"


letterP :: Parser Char
letterP = oneOfP $ ['a'..'z'] ++ ['A'..'Z']


digitP :: Parser Char
digitP = oneOfP ['0'..'9']


skipManyP :: (Char -> Bool) -> Parser ()
skipManyP pred = Parser f
    where
        f input = Right (left, ())
            where
                (_, left) = span pred input


spaceP :: Parser Char
spaceP = predP isSpace


spacesP :: Parser ()
spacesP = skipManyP isSpace


lineBeginWithP :: String -> Parser ()
lineBeginWithP begin = Parser f
    where 
        f s = if begin `isPrefixOf` s
            -- Skip util a '\n'
            then Right (getAfterNewline s, ())
            else Left . ParseError $ "Expected prefix '" ++ s ++ "'"

        getAfterNewline :: String -> String
        getAfterNewline str = case dropWhile (/= '\n') str of
            []     -> ""       
            (_:xs) -> xs       


noP :: Parser ()
noP = Parser f
    where
        f s = Right (s, ())

optionCharP :: Char -> Parser (Maybe Char)
optionCharP c = Parser f
    where 
        f all@(x:xs) = if x == c
            then Right (xs, Just c)
            else Right (all, Nothing)
        f [] = Left . ParseError $ "Option '" ++ [c] ++ "', but get empty string"

